home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Shareware Overload Trio 2
/
Shareware Overload Trio Volume 2 (Chestnut CD-ROM).ISO
/
dir31
/
gusutils.zip
/
GUSWAV.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1994-02-09
|
16KB
|
560 lines
(****************************************************************************)
(* Module : GUSWAV.PAS *)
(* Verion : 0.8ß *)
(* Date : Thu Feb 3, 1994 *)
(* Pascal : TP 7.0 *)
(****************************************************************************)
(* *)
(* NOTICE OF COPYRIGHT AND OWNERSHIP OF SOFTWARE: *)
(* *)
(* Copyright (C) 1993, 1994 by MESS Computer Services. *)
(* Portions Copyright (C) 1993, 1994 by TBP Electronics Ltd. *)
(* All rights reserved. *)
(* *)
(****************************************************************************)
(* MESS Computer Services V.O.F. MM MM EEEEEE SSSSS SSSSS *)
(* Jadestraat 54 M M M M E S S *)
(* 4817 JK Breda M M M EEEE SSSS SSSS *)
(* The Netherlands M M E S S *)
(* M M EEEEEE SSSSS SSSSS *)
(* Tel: +31-76 22 34 31 *)
(* Fax: +31-76 20 46 23 Many Efforts for Structured Systems *)
(* Email: appel@stack.urc.tue.nl *)
(****************************************************************************)
{$A-,B-,D+,E-,F-,G+,I-,L+,N-,O-,P-,Q-,R-,S-,T-,V-,X+}
{$M 4096,0,0}
program GusWav;
uses
Dos, Gus;
type
NameType = array [1..8] of Char;
GusSample = record
Id : array[1..4] of Char;
Name : NameType;
Start : LongInt;
Stop : LongInt;
Freq : Word;
Bits : Byte;
Chan : Byte;
Reserved : array[1..8] of Byte;
end;
const
Hex : array [0..15] of Char = '0123456789ABCDEF';
Empty : GusSample = (Id : 'MESS';
Name : ' ';
Start : 0;
Stop : 0;
Freq : 0;
Bits : 0;
Chan : 0;
Reserved : (0,0,0,0,0,0,0,0));
InvalidWav : String [20] = 'Error in .wav file: ';
SampleBank = 32;
var
GusIndex : array [1..SampleBank] of GusSample;
Available : LongInt;
Handle : File;
Buffer : Array [1.. 40320] of Byte;
BufSize : Word;
GusPtr : LongInt;
Path : String;
Filename : String;
Extension : String;
Index : Byte;
Sounds : Boolean;
function UpStr (St : String) : String;
var
Loop : Byte;
begin
UpStr[0] := St[0];
for Loop := 1 to Length(St)
do UpStr[Loop] := UpCase (St[Loop]);
end;
function HexStr (L : LongInt) : String;
var
St : String;
begin
St := '00000';
St[1] := Hex[L and $F0000 shr 16];
St[2] := Hex[L and $0F000 shr 12];
St[3] := Hex[L and $00F00 shr 8];
St[4] := Hex[L and $000F0 shr 4];
St[5] := Hex[L and $0000F shr 0];
HexStr := St;
end;
procedure Copyright;
begin
WriteLn;
WriteLn ('Gravis Ultrasound Wave Player V0.8ß');
WriteLn ('(C)Copyright MESS Computer Services 1993, 1994');
WriteLn;
end;
procedure InitGus;
var
Index : Byte;
Reload : Boolean;
begin
(* GUS MEMORY AVAILABLE *)
Available := LongInt(GusMemory) * 1024 - 1;
(* READ GUSINDEX *)
GusRead (0, GusIndex, SizeOf (GusIndex));
(* TEST GUSINDEX *)
Reload := False;
Index := 1;
repeat
Reload := Reload or (GusIndex[Index].Id <> Empty.Id);
Inc (Index);
until (Reload or (Index > SampleBank));
(* GUSINDEX NOT O.K. -> RESET GUS *)
if Reload then
begin
(* GUS INIT *)
GusInit (14);
(* RESET & WRITE GUSINDEX *)
for Index := 1 to SampleBank do GusIndex[Index] := Empty;
GusWrite (0, GusIndex, SizeOf (GusIndex));
(* OUTPUT ON *)
GusMixer (LineOut + LineIn);
end;
(* PLAY ALL SOUNDS *)
Sounds := True;
end;
procedure ShowIndex;
var
Index : Byte;
L1, L2 : Byte;
begin
Copyright;
if (GusBase = 0) then
begin
Write ('Error: ');
if MegaEm
then WriteLn ('Mega-Em is active.')
else WriteLn ('No Ultrasound card found.');
Halt (1);
end;
WriteLn ('Nr Name Start Stop Freq Bits Time Voices');
WriteLn ('-- -------- ------ ------ ----- ---------- ------ ------------');
for Index := 1 to SampleBank do
begin
if (GusIndex[Index].Freq <> 0) then
begin
if (Index <> 1) and ((Index - 1) mod 16 = 0) then
begin
Write ('-- More --');
asm
push ax
xor ah, ah
int 16h
pop ax
end;
WriteLn; WriteLn;
end;
Write (Index:2, ' ', GusIndex[Index].Name:8, ' ',
HexStr(GusIndex[Index].Start), 'h ', HexStr(GusIndex[Index].Stop), 'h ',
GusIndex[Index].Freq:5, ' ', GusIndex[Index].Bits:2, ' ');
case GusIndex[Index].Chan of
1 : Write ('Mono ');
2 : Write ('Stereo ');
else Write ('Multi-', GusIndex[Index].Chan, ' ');
end;
Write (((GusIndex[Index].Stop - GusIndex[Index].Start) shr
(GusIndex[Index].Bits shr 4) shr (GusIndex[Index].Chan shr 1) /
GusIndex[Index].Freq):5:1, 's ');
L2 := 0;
for L1 := 0 to GusVoices do
begin
if VoiceActive(L1) and (GetVoiceLoc (L1, LoopEnd) > GusIndex[Index].Start) and
(GetVoiceLoc (L1, LoopEnd) <= GusIndex[Index].Stop) then
begin
if (L2 >= 9) then
begin
if (L2 <= 12) then Write (Copy('....', 1, 13-L2));
L2 := 13;
end
else
begin
if (L2 > 0) then Write (',');
Write (L1+1);
end;
if (L1 >= 9) then Inc (L2, 3) else Inc (L2, 2);
end;
end;
WriteLn;
end;
end;
end;
function LoadFile (Index : Byte) : Boolean;
var
St : String;
Loop : Word;
Chan : Byte;
NxtLen : LongInt;
MaxLen : LongInt;
Header : array [1..16] of Word absolute Buffer;
DataPtr : LongInt;
begin
(* FILENAME *)
LoadFile := False;
Filename := Filename + '.WAV';
if (GusIndex[Index].Start >= Available) then Exit;
(* OPEN FILE *)
Assign (Handle, Path + Filename);
Reset (Handle, 1);
if (IOResult = 0) then
begin
(* CHECK WAV HEADER *)
St[0] := Chr(12);
BlockRead (Handle, St[1], 12, BufSize);
Delete (St, 5, 4);
if (St <> 'RIFFWAVE') then
begin
WriteLn (InvalidWav, Filename);
Exit;
end;
(* CHECK WAV FORMAT *)
St[0] := Chr(255);
BlockRead (Handle, St[1], 255, BufSize);
BufSize := Pos ('fmt ', St);
Delete (St, 1, BufSize-1);
if (BufSize = 0) or (Pos ('data', St) <> 25)then
begin
WriteLn (InvalidWav, Filename);
Exit;
end;
Seek (Handle, 12 + BufSize - 1);
BlockRead (Handle, Buffer, 32, BufSize);
DataPtr := FilePos (Handle);
(* GUSINDEX.FREQ & GUSINDEX.BITS *)
GusPtr := GusIndex[Index].Start;
GusIndex[Index].Bits := Header[12];
GusIndex[Index].Chan := Header[6];
GusIndex[Index].Freq := Header[7] shr (Header[6] shr 1);
if GusIndex[Index].Bits = 16 then
begin
GusDataConvert := False;
GusData16Bits := True;
end
else
begin
GusDataConvert := True;
GusData16Bits := False;
end;
if (GusIndex[Index].Chan > (8 shr (GusIndex[Index].Bits shr 4))) then
begin
WriteLn (GusIndex[Index].Bits, ' bits multi-channel .wav files with ',
(8 shr (GusIndex[Index].Bits shr 4) + 1), ' or more channels',
' are not supported...');
Exit;
end;
(* MAX LENGTH *)
MaxLen := Available - GusPtr - GusIndex[Index].Chan shl (GusIndex[Index].Bits shr 4);
for Chan := 1 to GusIndex[Index].Chan do
begin
Seek (Handle, DataPtr);
(* NEXT LENGTH *)
NxtLen := MaxLen div GusIndex[Index].Chan;
while not EOF (Handle) do
begin
BlockRead (Handle, Buffer, SizeOf (Buffer), BufSize);
if (BufSize div GusIndex[Index].Chan >= NxtLen) then
begin
BufSize := NxtLen * GusIndex[Index].Chan;
Seek (Handle, FileSize(Handle));
end;
if (GusIndex[Index].Chan <> 1) then
begin
BufSize := BufSize div GusIndex[Index].Chan;
for Loop := 0 to BufSize - 1
do Buffer[Loop+1] := Buffer[Loop * GusIndex[Index].Chan + Chan];
end;
GusWrite (GusPtr, Buffer, BufSize);
Dec (NxtLen, BufSize);
Inc (GusPtr, BufSize);
end;
(* GUSPTR = NEXT SAMPLE BYTE *)
GusPtr := (GusPtr and $FFFFE);
GusPoke (GusPtr, $00);
Inc (GusPtr);
if GusIndex[Index].Bits <> 8 then
begin
GusPoke (GusPtr, $00);
Inc (GusPtr);
end;
end;
(* GUSDATA *)
GusDataConvert := False;
GusData16Bits := False;
(* GUSINDEX.STOP *)
GusIndex[Index].Stop := GusPtr;
(* CLOSE FILE *)
Close (Handle);
(* LOADFILE := TRUE (O.K.) *)
LoadFile := True;
end;
end;
function FindFile (Name : String) : Byte; (* NAME = UPCASE *)
var
Found : Boolean;
Index : Byte;
Loop : Byte;
begin
(* SEARCH NAME *)
Name := Copy (Name+' ', 1, 8);
Index := 0;
(* SEARCH *)
repeat
Inc (Index);
Found := True;
for Loop := 1 to 8
do Found := Found and (GusIndex[Index].Name[Loop] = Name[Loop]);
until (Found or (GusIndex[Index].Freq = 0) or (Index > SampleBank));
(* NOT FOUND *)
if not Found and (Index <= SampleBank) then
begin
(* GUSINDEX.NAME *)
for Loop := 1 to 8
do GusIndex[Index].Name[Loop] := Name[Loop];
(* GUSINDEX.START *)
if (Index > 1)
then GusIndex[Index].Start := ((GusIndex[Index-1].Stop - 1) shr 5 + 1) shl 5
else GusIndex[Index].Start := SampleBank * SizeOf(GusSample);
(* WRITE GUSINDEX *)
if LoadFile (Index)
then GusWrite (0, GusIndex, SizeOf (GusIndex))
else Index := 0;
end;
(* FINDFILE *)
if (Index > SampleBank) then Index := 0;
FindFile := Index;
end;
procedure PlayFile (Nr : Byte);
var
Voice : array [1..8] of Byte;
Index : Byte;
Len : LongInt;
begin
if Sounds then
begin
if ((Nr >= 1) and (Nr <= SampleBank)) then
begin
(* FREE VOICES *)
Voice[1] := 0;
for Index := 1 to GusIndex[Nr].Chan do
begin
while VoiceActive (Voice[Index]) and (Voice[Index] < GusVoices)
do Inc (Voice[Index]);
if (Index < GusIndex[Nr].Chan) then Voice[Index + 1] := Voice [Index] + 1;
end;
for Index := 1 to GusIndex[Nr].Chan do
begin
if (Voice[Index] < GusVoices) then
begin
(* VOICE BALANCE *)
if GusIndex[Nr].Chan = 1 then VoiceBalance (Voice[Index], Middle)
else
begin
if Odd (Index)
then VoiceBalance (Voice[Index], Left)
else VoiceBalance (Voice[Index], Right);
end;
(* VOICE VOLUME *)
VoiceVolume (Voice[Index], $000);
(* VOICE MODE *)
if (GusIndex[Nr].Bits = 8)
then VoiceMode (Voice[Index], Bit8 + LoopOff + UniDir + Forw)
else VoiceMode (Voice[Index], Bit8 + LoopOff + UniDir + Forw);
(* SHOULD BE: BIT16 *)
(* VOICE FREQ *)
VoiceFreq (Voice[Index], GusIndex[Nr].Freq shl (GusIndex[Nr].Bits shr 4));
(* BECAUSE: BITS8 *)
(* VOICE SAMPLE *)
Len := (GusIndex[Nr].Stop - GusIndex[Nr].Start) div GusIndex[Nr].Chan;
VoiceSample (Voice[Index],
GusIndex[Nr].Start + (Index - 1) * Len,
GusIndex[Nr].Start + (Index - 1) * Len,
GusIndex[Nr].Start + Index * Len);
(* VOICE RAMP *)
RampRate (Voice[Index], 0, 34);
RampRange (Voice[Index], $000, $F00);
RampMode (Voice[Index], LoopOff+UniDir+Up);
end;
end;
for Index := 1 to GusIndex[Nr].Chan do
begin
if (Voice[Index] < GusVoices) then
begin
VoiceStart (Voice[Index]);
RampStart (Voice[Index]);
end;
end;
end;
end;
end;
begin
InitGus;
(* ANTI-VOLUME-CLIPPING *)
for Index := 0 to GusVoices - 1 do
if not VoiceActive (Index) then VoiceInit (Index);
(* INDEX *)
if (ParamCount = 0) then ShowIndex
else
for Index := 1 to ParamCount do
begin
(* FILENAME OR PARAMETER *)
FSplit (UpStr(ParamStr(Index)), Path, Filename, Extension);
if (Filename[1] = '/') or (Filename[1] = '-')
then Delete (Filename, 1, 1);
(* INDEX *)
if (Filename = 'INDEX') or (Filename = 'X') then
begin
ShowIndex;
end else begin
(* SILENCE *)
if (Filename = 'LOAD') or (Filename = 'L') then
begin
Sounds := False;
end else begin
(* SOUND ON *)
if (Filename = 'PLAY') or (Filename = 'P') then
begin
Sounds := True;
end else begin
(* INIT *)
if (Filename = 'INIT') or (Filename = 'I') then
begin
(* INIT GUS *)
GusInit (14);
(* OUTPUT ON *)
GusMixer (LineOut + LineIn);
(* SOUNDS ON *)
Sounds := True;
end else begin
(* CLEAR *)
if (Filename = 'CLEAR') or (Filename = 'C') then
begin
(* STOP VOICES *)
for BufSize := 0 to GusVoices - 1 do VoiceInit (BufSize);
(* RESET INDEX *)
for BufSize := 1 to SampleBank do GusIndex[BufSize] := Empty;
GusWrite (0, GusIndex, SizeOf (GusIndex));
end else begin
(* HELP *)
if (Filename = 'HELP') or (Filename = '?') then
begin
Copyright;
WriteLn ('Usage : GUSWAV [options] [switches] [drive:][path][filename] [#no]');
WriteLn;
WriteLn ('Options Short Explanation');
WriteLn ('-------- ----- -------------------------------------------------------');
WriteLn (' Stop -S Stop all samples from playing.');
WriteLn (' Init -I Initialize the Ultrasound but leave samples in memory.');
WriteLn (' Clear -C Clear all samples from the Ultrasound memory.');
WriteLn (' Index -X Show the samples in the Ultrasound memory (default).');
WriteLn (' Help -? Shows this help text.');
WriteLn;
WriteLn ('Switches Short Explanation');
WriteLn ('-------- ----- -------------------------------------------------------');
WriteLn (' Load -L Just load samples, don''t play.');
WriteLn (' Play -P Load and play samples (default).');
end else begin
(* STOP *)
if (Filename = 'STOP') or (Filename = 'S') then
begin
(* STOP VOICES *)
for BufSize := 0 to GusVoices - 1 do VoiceInit (BufSize);
end else
(* NUMBER OR FILENAME *)
begin
Val (Filename, BufSize, BufSize);
if (BufSize < 1) or (BufSize > SampleBank) then PlayFile (FindFile (Filename))
else if (GusIndex[BufSize].Freq <> 0) then PlayFile (BufSize);
end; end; end; end; end; end; end; end;
(* ANTI-VOLUME-CLIPPING *)
for Index := 0 to GusVoices - 1 do
if not VoiceActive (Index) then VoiceInit (Index);
end.